home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / e_to_l / imlib201 / tmulti.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  14KB  |  505 lines
  1. {Copyright 1995 by
  2.  Kevin Adams, 74742,1444
  3.  Jan Dekkers, 72130,353
  4.  
  5. }
  6.  
  7. {Part of Imagelib VCL/DLL Library.
  8.  
  9. Written by Jan Dekkers and Kevin Adams}
  10.  
  11.  
  12. unit TMulti;
  13.  
  14. interface
  15.  
  16. uses
  17.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls,
  18.   extctrls, StdCtrls, DLL20LIN, menus, Mask, Buttons;
  19.  
  20.  
  21. type
  22.   TMultiImage = class(TGraphicControl)
  23.   private
  24.     FPicture            : TPicture;
  25.     FAutoSize           : Boolean;
  26.     FStretch            : Boolean;
  27.     FCenter             : Boolean;
  28.     FReserved           : Byte;
  29.     FFilename           : TFileName;
  30.     Fdither             : byte;
  31.     FResolution         : byte;
  32.     FSaveQuality        : byte;
  33.     FSaveSmooth         : byte;
  34.     FSaveFileName       : TFileName;
  35.     Temps               : TFileName;
  36.     function GetCanvas: TCanvas;
  37.     procedure PictureChanged(Sender: TObject);
  38.     procedure SetAutoSize(Value: Boolean);
  39.     procedure SetCenter(Value: Boolean);
  40.     procedure SetPicture(Value: TPicture);
  41.     procedure SetStretch(Value: Boolean);
  42.   protected
  43.     function GetPalette: HPALETTE; override;
  44.   public
  45.     BFiletype           :  String;
  46.     Bwidth              :  Integer;
  47.     BHeight             :  Integer;
  48.     Bbitspixel          :  Integer;
  49.     Bplanes             :  Integer;
  50.     Bnumcolors          :  Integer;
  51.     BSize               :  Longint;
  52.     Bcompression        :  String;
  53.     constructor Create(AOwner: TComponent); override;
  54.     destructor Destroy; override;
  55.     property Canvas: TCanvas read GetCanvas;
  56.     function GetMultiBitmap : String;
  57.     Procedure WriteMultiName(Name : String);
  58.     procedure Paint; override;
  59.     function GetSmooth : Byte;
  60.     procedure SetSmooth(smooth : Byte);
  61.     function GetQuality : Byte;
  62.     procedure SetQuality(Quality : Byte);
  63.     function GetDither : Byte;
  64.     procedure SetDither(dith : Byte);
  65.     function GetRes : Byte;
  66.     procedure SetRes(res : Byte);
  67.     function GetSaveFileName : TFilename;
  68.     procedure SetSaveFileName(fn : TFilename);
  69.     procedure SaveAsJpg(FN : TFileName);
  70.     procedure SaveAsBMP(FN : TFileName);
  71.     function GetInfoAndType(filename : TFilename) : Boolean;
  72.   published
  73.     property Align;
  74.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  75.     property Center: Boolean read FCenter write SetCenter default False;
  76.     property DragCursor;
  77.     property DragMode;
  78.     property Enabled;
  79.     property JPegDither : Byte read GetDither write SetDither;
  80.     property JPegResolution : Byte read GetRes write SetRes;
  81.     property Picture: TPicture read FPicture write SetPicture;
  82.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  83.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  84.     property DefSaveFileName : TFileName read GetSaveFileName write SetSaveFileName;
  85.     property ImageName  : String read GetMultiBitmap write WriteMultiName;
  86.     property ParentShowHint;
  87.     property PopupMenu;
  88.     property ShowHint;
  89.     property Stretch: Boolean read FStretch write SetStretch default False;
  90.     property Visible;
  91.     property OnClick;
  92.     property OnDblClick;
  93.     property OnDragDrop;
  94.     property OnDragOver;
  95.     property OnEndDrag;
  96.     property OnMouseDown;
  97.     property OnMouseMove;
  98.     property OnMouseUp;
  99.   end;
  100.  
  101.  
  102. var
  103.  TMultiImageCallBack   : TCallBackFunction;
  104. {------------------------------------------------------------------------}
  105.  
  106. implementation
  107.  
  108.   uses Consts, Clipbrd, Dialogs;
  109.  
  110.  
  111. {------------------------------------------------------------------------
  112.  TMultiImage.
  113. ------------------------------------------------------------------------}
  114.  
  115.  
  116. constructor TMultiImage.Create(AOwner: TComponent);
  117. begin
  118.   inherited Create(AOwner);
  119.   FPicture := TPicture.Create;
  120.   FPicture.OnChange := PictureChanged;
  121.   FFilename:='';
  122.   Fdither:=4;
  123.   FResolution:=8;
  124.   FSaveQuality:=25;
  125.   FSaveSmooth:=0;
  126.   Picture.Graphic := nil;
  127.   Height := 105;
  128.   Width := 105;
  129.  end;
  130. {------------------------------------------------------------------------}
  131.  
  132.  
  133. destructor TMultiImage.Destroy;
  134. begin
  135.   FPicture.Free;
  136.   inherited Destroy;
  137. end;
  138. {------------------------------------------------------------------------}
  139.  
  140. function TMultiImage.GetPalette: HPALETTE;
  141. begin
  142.   Result := 0;
  143.   if FPicture.Graphic is TBitmap then
  144.     Result := TBitmap(FPicture.Graphic).Palette;
  145. end;
  146. {------------------------------------------------------------------------}
  147.  
  148. procedure TMultiImage.Paint;
  149. var
  150.   Dest: TRect;
  151. begin
  152.   if csDesigning in ComponentState then
  153.     with inherited Canvas do
  154.     begin
  155.       Pen.Style := psDash;
  156.       Brush.Style := bsClear;
  157.       Rectangle(0, 0, Width, Height);
  158.     end;
  159.   if Stretch then
  160.     Dest := ClientRect
  161.   else if Center then
  162.     Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  163.       Picture.Width, Picture.Height)
  164.   else
  165.     Dest := Rect(0, 0, Picture.Width, Picture.Height);
  166.   with inherited Canvas do
  167.     StretchDraw(Dest, Picture.Graphic);
  168. end;
  169.  
  170. {------------------------------------------------------------------------}
  171.  
  172. function TMultiImage.GetCanvas: TCanvas;
  173. var
  174.   Bitmap: TBitmap;
  175. begin
  176.   if Picture.Graphic = nil then
  177.   begin
  178.     Bitmap := TBitmap.Create;
  179.     try
  180.       Bitmap.Width := Width;
  181.       Bitmap.Height := Height;
  182.       Picture.Graphic := Bitmap;
  183.     finally
  184.       Bitmap.Free;
  185.     end;
  186.   end;
  187.   if Picture.Graphic is TBitmap then
  188.     Result := TBitmap(Picture.Graphic).Canvas
  189.   else
  190.     raise EInvalidOperation.Create(LoadStr(SImageCanvasNeedsBitmap));
  191. end;
  192. {------------------------------------------------------------------------}
  193.  
  194. procedure TMultiImage.SetAutoSize(Value: Boolean);
  195. begin
  196.   FAutoSize := Value;
  197.   PictureChanged(Self);
  198. end;
  199. {------------------------------------------------------------------------}
  200.  
  201. procedure TMultiImage.SetCenter(Value: Boolean);
  202. begin
  203.   if FCenter <> Value then
  204.   begin
  205.     FCenter := Value;
  206.     Invalidate;
  207.   end;
  208. end;
  209. {------------------------------------------------------------------------}
  210.  
  211. procedure TMultiImage.SetPicture(Value: TPicture);
  212. begin
  213.   FPicture.Assign(Value);
  214. end;
  215. {------------------------------------------------------------------------}
  216.  
  217. procedure TMultiImage.SetStretch(Value: Boolean);
  218. begin
  219.   FStretch := Value;
  220.   Invalidate;
  221. end;
  222. {------------------------------------------------------------------------}
  223.  
  224. procedure TMultiImage.PictureChanged(Sender: TObject);
  225. begin
  226.   if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  227.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  228.   if (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
  229.     (Picture.Height = Height) then
  230.     ControlStyle := ControlStyle + [csOpaque] else
  231.     ControlStyle := ControlStyle - [csOpaque];
  232.   Invalidate;
  233. end;
  234. {------------------------------------------------------------------------}
  235.  
  236. function TMultiImage.GetDither : Byte;
  237. begin
  238.   GetDither:=Fdither
  239. end;
  240. {------------------------------------------------------------------------}
  241.  
  242. procedure TMultiImage.SetDither(dith : Byte);
  243. begin
  244.   Fdither:=4;
  245.   case dith of
  246.             0..4 :Fdither:=dith;
  247.   end;
  248. end;
  249. {------------------------------------------------------------------------}
  250.  
  251. function TMultiImage.GetRes : Byte;
  252. begin
  253.   GetRes:=FResolution;
  254. end;
  255. {------------------------------------------------------------------------}
  256.  
  257.  
  258. procedure TMultiImage.SetRes(res : Byte);
  259. begin
  260.   FResolution:=8;
  261.   case res of
  262.             4 :FResolution:=res;
  263.             8 :FResolution:=res;
  264.             24 :FResolution:=res;
  265.   end;
  266. end;
  267. {------------------------------------------------------------------------}
  268.  
  269. Procedure TMultiImage.WriteMultiName(Name : String);
  270. begin
  271.   FFilename:=Name;
  272.   GetMultiBitmap;
  273. end;
  274. {------------------------------------------------------------------------}
  275.  
  276.  
  277. function TMultiImage.GetMultiBitmap :  String;
  278. var    bitmap     : TBitMap;
  279.        Pextension : string[4];
  280.        OnExcept   : Boolean;
  281.        f          : file of byte;
  282. label  BreakIt;
  283.  
  284. begin
  285.   OnExcept:=False;
  286.   if not F